(DECLARE (SETQ NO-DISK-HACKS T))
(DECLARE (REQUIRE UTIL 1 DSK (AID RPG)))
(DECLARE (READ))
(REQUIRE UTIL 1 DSK (AID RPG))


(DEFPROP LC0FNS
 (LC0FNS COMPL COMP PRUP MKPUSH COMPEXP COMPLIS LOADAC COMCOND COMBOOL COMPANDOR)
VALUE)

(DEFPROP COMPL
 (LAMBDA(FILE)
  (UWRITE)
  (APPLY (QUOTE EREAD) FILE)
  (SELECT-DISK-INPUT
   (READ-UNTIL-EOF
    WITH
    Z
    DO
    (COND ((OR (EQ (CAR Z) (QUOTE DEFUN)) (AND (EQ (CAR Z) (QUOTE DEFPROP)) (EQ (CADDDR Z) (QUOTE EXPR))))
	   (PROG (PROG)
		 (SETQ PROG
		       (COND ((EQ (CAR Z) (QUOTE DEFUN)) (COMP (CADR Z) (CADDR Z) (CADDDR Z)))
			     (T (COMP (CADR Z) (CADR (CADDR Z)) (CADDR (CADDR Z))))))
		 (UNSELECT-TTY (SELECT-DISK-OUTPUT (MAPC (FUNCTION PRINT) PROG)))
		 (PRINT (LIST (CADR Z) (LENGTH PROG)))))
	  (T (UNSELECT-TTY (SELECT-DISK-OUTPUT (PRINT Z))))))
   (APPLY (QUOTE UFILE) (LIST (CAR FILE) (QUOTE LAP)))
   (QUOTE ENDCOMP)))
FEXPR)

(DEFPROP COMP
 (LAMBDA(FN VARS EXP)
  ((LAMBDA(N)
    (APPEND (LIST (LIST (QUOTE LAP) FN (QUOTE SUBR)))
	    (MKPUSH N 1)
	    (COMPEXP EXP (MINUS N) NIL (PRUP VARS 1))
	    (LIST (LIST (QUOTE SUB) (QUOTE P) (LIST (QUOTE %) 0 0 N N)))
	    (QUOTE ((POPJ P) NIL))))
   (LENGTH VARS)))
EXPR)

(DEFPROP PRUP
 (LAMBDA (VARS N) (COND ((NULL VARS) NIL) (T (CONS (CONS (CAR VARS) N) (PRUP (CDR VARS) (ADD1 N))))))
EXPR)

(DEFPROP MKPUSH
 (LAMBDA (N M) (COND ((LESSP N M) NIL) (T (CONS (LIST (QUOTE PUSH) (QUOTE P) M) (MKPUSH N (ADD1 M))))))
EXPR)

(DEFPROP COMPEXP
 (LAMBDA(EXP M TAG VPR)
  (COND	((NULL EXP) (QUOTE ((MOVEI 1 0))))
	((EQ EXP T) (QUOTE ((MOVEI 1 (QUOTE T)))))
	((NUMBERP EXP) (LIST (LIST (QUOTE MOVEI) 1 (LIST (QUOTE QUOTE) EXP))))
	((ATOM EXP) (LIST (LIST (QUOTE MOVE) 1 (PLUS M (CDR (ASSOC EXP VPR))) (QUOTE P))))
	((OR (EQ (CAR EXP) (QUOTE AND)) (EQ (CAR EXP) (QUOTE OR)) (EQ (CAR EXP) (QUOTE NOT)))
	 ((LAMBDA(L1 L2)
	   (APPEND (COMBOOL EXP M L1 NIL (CONS 1 TAG) VPR)
		   (LIST (QUOTE (MOVEI 1 (QUOTE T))) (LIST (QUOTE JRST) 0 L2) L1 (QUOTE (MOVEI 1 0)) L2)))
	  (CONS 1 TAG)
	  (CONS 2 TAG)))
	((EQ (CAR EXP) (QUOTE COND)) (COMCOND (CDR EXP) M (CONS 1 TAG) (CONS 1 TAG) VPR))
	((EQ (CAR EXP) (QUOTE QUOTE)) (LIST (LIST (QUOTE MOVEI) 1 EXP)))
	((ATOM (CAR EXP))
	 ((LAMBDA(N)
	   (APPEND (COMPLIS (CDR EXP) M (CONS 1 TAG) VPR)
		   (LOADAC (DIFFERENCE 1 N) 1)
		   (LIST (LIST (QUOTE SUB) (QUOTE P) (LIST (QUOTE %) 0 0 N N)))
		   (LIST (LIST (QUOTE CALL) N (LIST (QUOTE QUOTE) (CAR EXP))))))
	  (LENGTH (CDR EXP))))
	((EQ (CAAR EXP) (QUOTE LAMBDA))
	 ((LAMBDA(N)
	   (APPEND (COMPLIS (CDR EXP) M (CONS 1 TAG) VPR)
		   (COMPEXP (CADDAR EXP) (DIFFERENCE M N) (CONS 2 TAG) (APPEND (PRUP (CADAR EXP) (DIFFERENCE 1 M)) VPR))
		   (LIST (LIST (QUOTE SUB) (QUOTE P) (LIST (QUOTE %) 0 0 N N)))))
	  (LENGTH (CDR EXP))))
	(T NIL)))
EXPR)

(DEFPROP COMPLIS
 (LAMBDA(U M TAG VPR)
  (COND	((NULL U) NIL)
	(T (APPEND (COMPEXP (CAR U) M (CONS 1 TAG) VPR) (QUOTE ((PUSH P 1))) (COMPLIS (CDR U) (SUB1 M) (CONS 2 TAG) VPR)))))
EXPR)

(DEFPROP LOADAC
 (LAMBDA(N K)
  (COND ((GREATERP N 0) NIL) (T (CONS (LIST (QUOTE MOVE) K N (QUOTE P)) (LOADAC (ADD1 N) (ADD1 K))))))
EXPR)

(DEFPROP COMCOND
 (LAMBDA(U M L TAG VPR)
  (COND	((NULL U) (LIST L))
	(T
	 ((LAMBDA(L1)
	   (APPEND (COMBOOL (CAAR U) M L1 NIL (CONS 1 TAG) VPR)
		   (COMPEXP (CADAR U) M (CONS 2 TAG) VPR)
		   (LIST (LIST (QUOTE JRST) 0 L) L1)
		   (COMCOND (CDR U) M L (CONS 3 TAG) VPR)))
	  (CONS 1 TAG)))))
EXPR)

(DEFPROP COMBOOL
 (LAMBDA(P M L FLG TAG VPR)
  (COND	((ATOM P) (APPEND (COMPEXP P M (CONS 1 TAG) VPR) (LIST (LIST (COND (FLG (QUOTE JUMPN)) (T (QUOTE JUMPE))) 1 L))))
	((EQ (CAR P) (QUOTE AND))
	 (COND ((NOT FLG) (COMPANDOR (CDR P) M L NIL (CONS 1 TAG) VPR))
	       (T
		((LAMBDA(L1)
		  (APPEND (COMPANDOR (CDR P) M L1 NIL (CONS 1 TAG) VPR) (LIST (LIST (QUOTE JRST) 0 L)) (LIST L1)))
		 (CONS 1 TAG)))))
	((EQ (CAR P) (QUOTE OR))
	 (COND (FLG (COMPANDOR (CDR P) M L T (CONS 1 TAG) VPR))
	       (T
		((LAMBDA (L1) (APPEND (COMPANDOR (CDR P) M L1 T (CONS 1 TAG) VPR) (LIST (LIST (QUOTE JRST) 0 L)) (LIST L1)))
		 (CONS 1 TAG)))))
	((EQ (CAR P) (QUOTE NOT)) (COMBOOL (CADR P) M L (NOT FLG) (CONS 1 TAG) VPR))
	(T (APPEND (COMPEXP P M (CONS 1 TAG) VPR) (LIST (LIST (COND (FLG (QUOTE JUMPN)) (T (QUOTE JUMPE))) 1 L))))))
EXPR)

(DEFPROP COMPANDOR
 (LAMBDA(U M L FLG TAG VPR)
  (COND ((NULL U) NIL) (T (APPEND (COMBOOL (CAR U) M L FLG (CONS 1 TAG) VPR) (COMPANDOR (CDR U) M L FLG (CONS 2 TAG) VPR)))))
EXPR)